home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / utils / live-icon.el.z / live-icon.el
Encoding:
Text File  |  1998-05-21  |  10.1 KB  |  329 lines
  1. ;; live-icon.el --- make frame icons represent the current frame contents
  2.  
  3. ;; Copyright (C) 1995 Rich Williams <rdw@hplb.hpl.hp.com>
  4. ;; Copyright (C) 1995 Jamie Zawinski <jwz@netscape.com>
  5.  
  6. ;; Authors: Rich Williams <rdw@hplb.hpl.hp.com>
  7. ;;          Jamie Zawinski <jwz@netscape.com>
  8.  
  9. ;; Minor cleanups and conversion from obsolete functions by
  10. ;; Karl M. Hegbloom <karlheg@inetarena.com>
  11.  
  12. ;; Version 1.3
  13.  
  14.  
  15. ;; This file is part of XEmacs.
  16.  
  17. ;; XEmacs is free software; you can redistribute it and/or modify it
  18. ;; under the terms of the GNU General Public License as published by
  19. ;; the Free Software Foundation; either version 2, or (at your option)
  20. ;; any later version.
  21.  
  22. ;; XEmacs is distributed in the hope that it will be useful, but
  23. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  24. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  25. ;; General Public License for more details.
  26.  
  27. ;; You should have received a copy of the GNU General Public License
  28. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  29. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  30. ;; Boston, MA 02111-1307, USA.
  31.  
  32. ;;; Synched up with: Not in FSF.
  33.  
  34. ;; Generates little pixmaps representing the contents of your frames.
  35.  
  36. (defun live-icon-alloc-colour (cmv colour)
  37.   "Allocate a colour and a char from the magic vector"
  38.   (let ((bob (assoc colour (aref cmv 0)))
  39.     (jim (aref cmv 2)))
  40.     (if bob
  41.     (cdr bob)
  42.       (aset cmv 0 (cons (cons colour jim) (aref cmv 0)))
  43.       (aset cmv 1 (1+ (aref cmv 1)))
  44.       (aset cmv 2 (1+ jim))
  45.       jim)))
  46.  
  47. (defun live-icon-from-frame (&optional frame)
  48.   "Calculates the live-icon XPM of FRAME."
  49.   (if (not frame)
  50.       (setq frame (selected-frame)))
  51.   (save-excursion
  52.     (select-frame frame)
  53.     (let* ((w (frame-width))
  54.        (h (frame-height))
  55.        (pix (make-vector h nil))
  56.        (ny 0)
  57.        (cmv (vector nil 0 ?A))
  58.        (d (live-icon-alloc-colour
  59.            cmv (color-name (face-background 'default))))
  60.        (m (live-icon-alloc-colour
  61.            cmv (color-name (face-background 'modeline))))
  62.        (x (live-icon-alloc-colour
  63.            cmv (color-name (face-foreground 'default))))
  64.        y)
  65.       (let ((loop 0))
  66.     (while (< loop h)
  67.       (aset pix loop (make-string w d))
  68.       (setq loop (1+ loop))))
  69.       (mapcar #'(lambda (win)
  70.               (save-excursion
  71.             (save-window-excursion
  72.               (select-window win)
  73.               (save-restriction
  74.                 (setq y ny
  75.                   ny (+ ny (1- (window-height))))
  76.                 (aset pix (- ny 2) (make-string w m))
  77.                 (widen)
  78.                 (if (> (window-end) (window-start))
  79.                 (narrow-to-region (window-start)
  80.                           (1- (window-end))))
  81.                 (goto-char (point-min))
  82.                 (while (and (not (eobp))
  83.                     (< y (1- ny)))
  84.                   (while (and (not (eolp))
  85.                       (< (current-column) w))
  86.                 (if (> (char-after (point)) 32)
  87.                     (let* ((ex (extent-at (point) (current-buffer) 'face))
  88.                        (f (if ex (let ((f (extent-face ex)))
  89.                                (if (not (consp f))
  90.                                f
  91.                              (car f)))))
  92.                        (z (if f (color-name (face-foreground f))))
  93.                        (c (if z (live-icon-alloc-colour cmv z) x)))
  94.                       (aset (aref pix y) (current-column) c)))
  95.                 (forward-char 1))
  96.                   (setq y (1+ y))
  97.                   (forward-line 1))))))
  98.           (sort (if (fboundp 'window-list)
  99.             (window-list)
  100.               (let* ((w (frame-root-window))
  101.                  (ws nil))
  102.             (while (not (memq (setq w (next-window w)) ws))
  103.               (setq ws (cons w ws)))
  104.             ws))
  105.             #'(lambda (won woo)
  106.                 (< (nth 1 (window-pixel-edges won))
  107.                    (nth 1 (window-pixel-edges woo))))))
  108.       (concat "/* XPM */\nstatic char icon[] = {\n" 
  109.           (format "\"%d %d %d 1\",\n" w (* h 2) (aref cmv 1))
  110.           (mapconcat #'(lambda (colour-entry)
  111.                (format "\"%c c %s\"" 
  112.                    (cdr colour-entry) 
  113.                    (car colour-entry)))
  114.              (aref cmv 0)
  115.              ",\n")
  116.           ",\n"
  117.           (mapconcat #'(lambda (scan-line)
  118.                (concat "\"" scan-line "\"," "\n"
  119.                    "\"" (make-string w d) "\","
  120.                    ))
  121.              pix
  122.              ",\n")
  123.           "};\n"))))
  124.  
  125. (defun live-icon-one-frame (&optional frame)
  126.   "Gives FRAME (defaulting to (selected-frame)) a live icon."
  127.   (interactive)
  128.   (unless frame
  129.     (setq frame (selected-frame)))
  130.   (unless (frame-property frame 'balloon-help)
  131.     (set-glyph-image frame-icon-glyph (live-icon-from-frame frame) frame)))
  132.  
  133. ;;(defun live-icon-all-frames ()
  134. ;;  "Gives all your frames live-icons."
  135. ;;  (interactive)
  136. ;;  (mapcar #'(lambda (fr)
  137. ;;          (set-glyph-image frame-icon-glyph
  138. ;;                   (live-icon-from-frame fr)
  139. ;;                   fr))
  140. ;;      (frame-list)))
  141.  
  142. (add-hook 'unmap-frame-hook 'live-icon-one-frame)
  143. ;;(start-itimer "live-icon" 'live-icon-all-frames 120 120)
  144.  
  145. (provide 'live-icon)
  146. ;;; live-icon.el ends here
  147.  
  148.  
  149.  
  150. ;;;; Spare parts and leftovers department:
  151.  
  152. ;; #### This thing is somewhat of a mess and could stand some clean-up.
  153.  
  154. ;;(defun live-icon-colour-name-from-face (face &optional bg-p)
  155. ;;  "Do backward compatible things to faces and colours"
  156. ;;  (if (and (boundp 'emacs-major-version)
  157. ;;       (or (> emacs-major-version 19)
  158. ;;           (and (= emacs-major-version 19)
  159. ;;            (>= emacs-minor-version 12))))
  160. ;;      (let* ((face (if (consp face) (car face) face))
  161. ;;         (colour (if bg-p
  162. ;;             (face-background face)
  163. ;;               (face-foreground face))))
  164. ;;    (if (consp colour)
  165. ;;        (setq colour (cdr (car colour))))
  166. ;;    (if (color-instance-p colour)
  167. ;;        (setq colour (color-instance-name colour)))
  168. ;;    (if (specifierp colour)
  169. ;;        (setq colour (color-name colour)))
  170. ;;    (if colour
  171. ;;        (let ((hack (format "%s" colour)))
  172. ;;          (if (string-match "(?\\([^)]*\\))?" hack)
  173. ;;          (substring hack (match-beginning 1) (match-end 1))
  174. ;;        hack))))
  175. ;;    (let ((p (if bg-p (face-background face) (face-foreground face))))
  176. ;;      (and (pixelp p)
  177. ;;       ;; ** The following functions are not known to be defined:  pixelp
  178. ;;       (pixel-name p)))))
  179. ;;;;  ** pixel-name is an obsolete function; use color-name instead.
  180.  
  181. ;;(defun live-icon-start-ppm-stuff (&optional frame)
  182. ;;  "Start a live icon conversion going"
  183. ;;  (interactive)
  184. ;;  (if (not frame)
  185. ;;      (setq frame (selected-frame)))
  186. ;;  (let ((buf (get-buffer-create " *live-icon*")))
  187. ;;    (message "live-icon...(backgrounding)")
  188. ;;    (save-excursion
  189. ;;      (set-buffer buf)
  190. ;;      (erase-buffer))
  191. ;;    (set-process-sentinel
  192. ;;     (start-process-shell-command "live-icon"
  193. ;;                  buf
  194. ;;                  "xwd"
  195. ;;                  "-id" (format "%s" (x-window-id frame)) "|"
  196. ;;                  "xwdtopnm" "|" 
  197. ;;                  "pnmscale" "-xysize" "64" "64" "|"
  198. ;;                  "ppmquant" "256" "|"
  199. ;;                  "ppmtoxpm")
  200. ;;     #'(lambda (p s)
  201. ;;     (message "live-icon...(munching)")
  202. ;;     (save-excursion
  203. ;;       (set-buffer " *live-icon*")
  204. ;;       (goto-char (point-min))
  205. ;;       (search-forward "/* XPM */")
  206. ;;       (set-glyph-image frame-icon-glyph
  207. ;;                (buffer-substring (match-beginning 0) (point-max))
  208. ;;                frame))
  209. ;;     (message "live-icon...... done"))))
  210. ;;  nil)
  211.  
  212. ;;(defun live-icon-goto-position (x y)
  213. ;;  (let (window edges)
  214. ;;    (catch 'done
  215. ;;      (walk-windows
  216. ;;       #'(lambda (w)
  217. ;;       (setq edges (window-edges w))
  218. ;;       (if (and (>= x (nth 0 edges))
  219. ;;            (<= x (nth 2 edges))
  220. ;;            (>= y (nth 1 edges))
  221. ;;            (<= y (nth 3 edges)))
  222. ;;           (throw 'done (setq window w))))
  223. ;;       nil t))
  224. ;;    (if (not window)
  225. ;;    nil
  226. ;;      (select-window window)
  227. ;;      (move-to-window-line (- y (nth 1 edges)))
  228. ;;      (move-to-column (- x (nth 0 edges)))
  229. ;;      )))
  230.  
  231. ;;(defun live-icon-make-image (width height)
  232. ;;  (let* ((text-aspect 1.5)
  233. ;;     (xscale (/ (/ (* (frame-width)  1.0) width) text-aspect))
  234. ;;     (yscale (/ (* (frame-height) 1.0) height))
  235. ;;     (x 0)
  236. ;;     (y 0)
  237. ;;     (cmv (vector nil 0 ?A))
  238. ;;     (default-fg (live-icon-alloc-colour
  239. ;;              cmv (color-name (face-foreground 'default))))
  240. ;;     (default-bg (live-icon-alloc-colour
  241. ;;              cmv (color-name (face-background 'default))))
  242. ;;     (modeline-bg (live-icon-alloc-colour
  243. ;;               cmv (color-name (face-background 'modeline))))
  244. ;;     (lines (make-vector height nil)))
  245. ;;    ;;
  246. ;;    ;; Put in the text.
  247. ;;    ;;
  248. ;;    (save-excursion
  249. ;;      (save-window-excursion
  250. ;;    (while (< y height)
  251. ;;      (aset lines y (make-string width default-bg))
  252. ;;      (setq x 0)
  253. ;;      (while (< x width)
  254. ;;        (let ((sx (floor (* x xscale)))
  255. ;;          (sy (floor (* y yscale))))
  256. ;;          (live-icon-goto-position sx sy)
  257. ;;          (let* ((extent (extent-at (point) (current-buffer) 'face))
  258. ;;             (face (if extent (extent-face extent)))
  259. ;;             (name (if face (live-icon-colour-name-from-face
  260. ;;                     face (<= (char-after (point)) 32))))
  261. ;;             (color (if name
  262. ;;                (live-icon-alloc-colour cmv name)
  263. ;;                  (if (<= (or (char-after (point)) 0) 32)
  264. ;;                  default-bg default-fg))))
  265. ;;        (aset (aref lines y) x color)))
  266. ;;        (setq x (1+ x)))
  267. ;;      (setq y (1+ y)))))
  268. ;;    ;;
  269. ;;    ;; Now put in the modelines.
  270. ;;    ;;
  271. ;;    (let (sx sy)
  272. ;;      (walk-windows
  273. ;;       #'(lambda (w)
  274. ;;       (let ((edges (window-edges w)))
  275. ;;         (setq x (nth 0 edges)
  276. ;;           y (nth 3 edges)
  277. ;;           sx (floor (/ x xscale))
  278. ;;           sy (floor (/ y yscale)))
  279. ;;         (while (and (< x (1- (nth 2 edges)))
  280. ;;             (< sx (length (aref lines 0))))
  281. ;;           (aset (aref lines sy) sx modeline-bg)
  282. ;;           (if (> sy 0)
  283. ;;           (aset (aref lines (1- sy)) sx modeline-bg))
  284. ;;           (setq x (1+ x)
  285. ;;             sx (floor (/ x xscale))))
  286. ;;         (if (>= sx (length (aref lines 0)))
  287. ;;         (setq sx (1- sx)))
  288. ;;         (while (>= y (nth 1 edges))
  289. ;;           (aset (aref lines sy) sx modeline-bg)
  290. ;;           (setq y (1- y)
  291. ;;             sy (floor (/ y yscale))))))
  292. ;;       nil nil))
  293. ;;    ;;
  294. ;;    ;; Now put in the top and left edges
  295. ;;    ;;
  296. ;;    (setq x 0)
  297. ;;    (while (< x width)
  298. ;;      (aset (aref lines 0) x modeline-bg)
  299. ;;      (setq x (1+ x)))
  300. ;;    (setq y 0)
  301. ;;    (while (< y height)
  302. ;;      (aset (aref lines y) 0 modeline-bg)
  303. ;;      (setq y (1+ y)))
  304. ;;    ;;
  305. ;;    ;; Now make the XPM
  306. ;;    ;;
  307. ;;    (concat "/* XPM */\nstatic char icon[] = {\n" 
  308. ;;        (format "\"%d %d %d 1\",\n"
  309. ;;            width
  310. ;;;;            (* height 2)
  311. ;;            height
  312. ;;            (aref cmv 1))
  313. ;;        (mapconcat #'(lambda (colour-entry)
  314. ;;               (format "\"%c c %s\""
  315. ;;                   (cdr colour-entry) 
  316. ;;                   (car colour-entry)))
  317. ;;               (aref cmv 0)
  318. ;;               ",\n")
  319. ;;        ",\n"
  320. ;;        (mapconcat #'(lambda (scan-line)
  321. ;;               (concat "\"" scan-line "\"," "\n"
  322. ;;;;                   "\"" scan-line "\""
  323. ;;;;                   "\"" (make-string width default-bg)
  324. ;;;;                   "\","
  325. ;;                   ))
  326. ;;               lines
  327. ;;               ",\n")
  328. ;;        "};\n")))
  329.